home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
ansi_130.zip
/
PINGANSI.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-06-03
|
16KB
|
528 lines
{$DEFINE Music}
{$DEFINE BBS}
{$UNDEF Small}
{ $A+,B-,D-,E-,F+,I-,L-,O+,R-,S-,V-}
(*
PingAnsi v 1.30 (c) CopyRight 1990 P.H.Rankin Hansen.
This unit provides partial Ansi emulation for Turbo Pascal versions
5.x and higher. (version 4 does not support procedural types). Some
routines are handled in a non-standard way.
Released in Denmark on June 3rd 1990.
By using this material You assume FULL responsibility for ANY
consequences - direct or indirect - thereof.
Any dispute regarding this material shall be setteled by Danish law
and in a Danish Court.
(Sigh!)
This source may NOT be used by Lawyers, Politicians or, persons
engaged in any other form of terrorism. Otherwise the usage is
free.
This source may be freely distributed as long as no fee is charged.
Please direct any comments, corrections, modifications via netmail
to:
Ping Hansen - Fido Net 2:231/62.58
*)
Unit PingAnsi;
{-}
Interface
Uses
{ Standard units }
Dos,
{ Turbo Power units. The standard CRT unit will not work in a TSR }
TpCrt, TpString;
Const
Title = 'PingAnsi v1.30 (c) CopyRight P.H.Rankin Hansen 1990.';
Var
Ansi : Text; { Ansi is the name of the device }
Wrap : Boolean; { True if Cursor should wrap }
ReportedX,
ReportedY : Word; { X,Y reported }
{ hook for implementing Your own Device Status Report procedure }
ReplyHook : Procedure(St : String);
{ hook for implementing Your own KeyBoard ReAssignment }
KeyHook : Procedure(St : String);
{ Hook for handling control chars i.e. Ch < Space }
WriteHook : Procedure(Ch : Char);
{$IFNDEF Small}
{$IFDEF BBS}
{ Hook for handling simultaneous writes to ComPort and Screen }
BBsHook : Procedure (Ch : Char);
{$ENDIF}
{$ENDIF}
{$IFDEF Music}
{ Hook for handling music }
PlayHook : Procedure(St : String);
{$ENDIF}
Function In_Ansi : Boolean; { True if a sequence is pending }
Procedure AnsiWrite(Ch : Char);
{$IFNDEF Small}
Procedure AssignAnsi(Var f : Text); { use like AssignCrt }
{$ENDIF}
Implementation
Type
States = (Waiting, Bracket, Get_Args, Get_Param, Eat_Semi,
Get_String, In_Param, Get_Music);
Const
St : String = '';
ParamArr : Array[1..10] Of Word = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
Params : Word = 0; { number of parameters }
NextState : States = Waiting; { next state for the parser }
Reverse : Boolean = False; { true if text attributes are reversed }
Var
Quote : Char;
SavedX, SavedY : Word;
Function In_Ansi : Boolean; { True if a sequence is pending }
Begin
In_Ansi := (NextState <> Waiting) And (NextState <> Bracket);
End {In_Ansi} ;
{$F+}
Procedure Report(St : String);
{$F-}
Begin
StuffString(St);
End;
{$F+}
Procedure WriteChar(Ch : Char);
{$F-}
Begin
Case Ch Of
#7 :
Begin
NoSound;
Sound(500);
Delay(50);
NoSound;
Delay(50);
End;
#8 : If (WhereX > 1) Then Write(#8' '#8);
#9 : If (WhereX < 71) Then
Repeat
GotoXy(WhereX + 1, Wherey);
Until (WhereX Mod 8 = 1);
Else
Write(Ch);
End {Case} ;
End {WriteChar} ;
{$F+}
Procedure Dummy(St : String);
{$F-}
Begin
End;
Procedure AnsiWrite(Ch : Char);
Var
i : Word;
Label Command;
Begin
If Ch = #27 Then
Begin
NextState := Bracket;
Exit;
End;
Case NextState Of
Waiting : If (Ch > ' ') Then Write(Ch)
Else WriteHook(Ch);
Bracket :
Begin
If Ch <> '[' Then
Begin
NextState := Waiting;
If (Ch > ' ') Then Write(Ch)
Else WriteHook(Ch);
Exit;
End;
St := '';
Params := 1;
FillChar(ParamArr, 10, 0);
NextState := Get_Args;
End;
Get_Args, Get_Param, Eat_Semi :
Begin
{$IFNDEF Music}
If (NextState = Get_Args) And ((Ch = '=') Or (Ch = '?')) Then
Begin
NextState := Get_Param;
Exit;
End;
{$ELSE}
If (NextState = Get_Args) Then
Case Ch Of
'=', '?' :
Begin
NextState := Get_Param;
Exit;
End;
'M' :
Begin
NextState := Get_Music;
Exit;
End;
End {Case} ;
{$ENDIF}
If (NextState = Eat_Semi) And (Ch = ';') Then
Begin
If Params < 10 Then Inc(Params);
NextState := Get_Param;
Exit;
End;
Case Ch Of
'0'..'9' :
Begin
ParamArr[Params] := Ord(Ch) - Ord('0');
NextState := In_Param;
End;
';' :
Begin
If Params < 10 Then Inc(Params);
NextState := Get_Param;
End;
'"', '''' :
Begin
Quote := Ch;
St := St + Ch;
NextState := Get_String;
End;
Else
GoTo Command;
End {Case Ch} ;
End;
Get_String :
Begin
St := St + Ch;
If Ch <> Quote
Then NextState := Get_String
Else NextState := Eat_Semi;
End;
In_Param : { last char was a digit }
Begin
{ looking for more digits, a semicolon, or a command char }
Case Ch Of
'0'..'9' :
Begin
ParamArr[Params] := ParamArr[Params] * 10 + Ord(Ch) - Ord('0');
NextState := In_Param;
Exit;
End;
';' :
Begin
If Params < 10 Then Inc(Params);
NextState := Eat_Semi;
Exit;
End;
End {Case Ch} ;
Command:
NextState := Waiting;
Case Ch Of
{ Note: the order of commands is optimized for execution speed }
'm' : {sgr}
Begin
For i := 1 To Params Do
Begin
If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
Case ParamArr[i] Of
0 :
Begin
Reverse := False;
TextAttr := 7;
End;
1 : TextAttr := TextAttr And $FF Or $08;
2 : TextAttr := TextAttr And $F7 Or $00;
4 : TextAttr := TextAttr And $F8 Or $01;
5 : TextAttr := TextAttr Or $80;
7 : If Not Reverse Then
Begin
{
TextAttr := TextAttr shr 4 + TextAttr shl 4;
}
Reverse := True;
End;
22 : TextAttr := TextAttr And $F7 Or $00;
24 : TextAttr := TextAttr And $F8 Or $04;
25 : TextAttr := TextAttr And $7F Or $00;
27 : If Reverse Then
Begin
Reverse := False;
{
TextAttr := TextAttr shr 4 + TextAttr shl 4;
}
End;
30 : TextAttr := TextAttr And $F8 Or $00;
31 : TextAttr := TextAttr And $F8 Or $04;
32 : TextAttr := TextAttr And $F8 Or $02;
33 : TextAttr := TextAttr And $F8 Or $06;
34 : TextAttr := TextAttr And $F8 Or $01;
35 : TextAttr := TextAttr And $F8 Or $05;
36 : TextAttr := TextAttr And $F8 Or $03;
37 : TextAttr := TextAttr And $F8 Or $07;
40 : TextAttr := TextAttr And $8F Or $00;
41 : TextAttr := TextAttr And $8F Or $40;
42 : TextAttr := TextAttr And $8F Or $20;
43 : TextAttr := TextAttr And $8F Or $60;
44 : TextAttr := TextAttr And $8F Or $10;
45 : TextAttr := TextAttr And $8F Or $50;
46 : TextAttr := TextAttr And $8F Or $30;
47 : TextAttr := TextAttr And $8F Or $70;
End {Case} ;
{ fixup for reverse }
If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
End;
End;
'A' : {cuu}
Begin
If ParamArr[1] = 0 Then ParamArr[1] := 1;
If (Wherey - ParamArr[1] >= 1)
Then GotoXy(WhereX, Wherey - ParamArr[1])
Else GotoXy(WhereX, Hi(WindMax));
End;
'B' : {cud}
Begin
If ParamArr[1] = 0 Then ParamArr[1] := 1;
If (Wherey + ParamArr[1] <= Hi(WindMax))
Then GotoXy(WhereX, Wherey + ParamArr[1])
Else GotoXy(WhereX, 1);
End;
'C' : {cuf}
Begin
If ParamArr[1] = 0 Then ParamArr[1] := 1;
If WhereX + ParamArr[1] <= Lo(WindMax)
Then GotoXy(WhereX + ParamArr[1], Wherey)
Else GotoXy(Lo(WindMax), Wherey);
End;
'D' : {cub}
Begin
If ParamArr[1] = 0 Then ParamArr[1] := 1;
If (WhereX - ParamArr[1] >= 1)
Then GotoXy(WhereX - ParamArr[1], Wherey)
Else GotoXy(1, Wherey);
End;
'H', 'f' : {cup,hvp}
Begin
If ParamArr[1] = 0 Then ParamArr[1] := 1;
If ParamArr[2] = 0 Then ParamArr[2] := 1;
GotoXy(ParamArr[2], ParamArr[1]);
End;
'J' : {EID}
Case ParamArr[1] Of
2 : ClrScr;
0 : {ClrEos}
Begin
ClrEol;
ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey + 1,
Lo(WindMax) + 1, Hi(WindMax) + 1, 0);
End;
1 : {Clear from beginning of screen}
Begin
ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
Lo(WindMin) + WhereX,
Hi(WindMin) + Wherey, 0);
ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + 1,
Lo(WindMax) + 1, Hi(WindMin) + Wherey - 1, 0);
End;
End {Case} ;
'K' : {eil}
Case ParamArr[1] Of
0 : ClrEol;
1 : { clear from beginning of line to cursor }
ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
Lo(WindMin) + WhereX - 1,
Hi(WindMin) + Wherey, 0);
2 : { clear entire line }
ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
Lo(WindMax) + 1,
Hi(WindMin) + Wherey, 0);
End {Case ParamArr} ;
'L' : {il } For i := 1 To ParamArr[1] Do InsLine; { must not move cursor }
'M' : {d_l} For i := 1 To ParamArr[1] Do DelLine; { must not move cursor }
'P' : {dc }
Begin
End;
'R' : {cpr}
Begin
ReportedY := ParamArr[1];
ReportedX := ParamArr[2];
End;
'@' : {ic}
Begin
{ insert blank chars }
End;
'h', 'l' : {sm/rm}
Case ParamArr[1] Of
0 : TextMode(BW40);
1 : TextMode(CO40);
2 : TextMode(BW80);
3 : TextMode(CO80);
4 : {GraphMode(320x200 col)} ;
5 : {GraphMode(320x200 BW)} ;
6 : {GraphMode(640x200 BW)} ;
7 : Wrap := Ch = 'h';
End {case} ;
'n' : {dsr}
If (ParamArr[1] = 6) Then
ReplyHook(#27'[' + Long2str(Wherey) + ';' +
Long2str(WhereX) + 'R');
's' : {scp}
Begin
SavedX := WhereX;
SavedY := Wherey;
End;
'u' : {rcp} GotoXy(SavedX, SavedY);
'p' : {keyboard reassignment}
KeyHook(St);
Else
Begin
If (Ch > ' ') Then Write(Ch)
Else WriteHook(Ch);
Exit;
End;
End {Case Ch} ;
End;
{$IFDEF Music}
Get_Music :
Begin
If Ch <> #3 {Ctrl-C}
Then St := St + Ch
Else
Begin
NextState := Waiting;
PlayHook(St);
End;
End;
{$ENDIF}
End {Case NextState} ;
End {AnsiWrite} ;
{$IFNDEF Small}
{$F+} { All Driver function must be far }
Function Nothing(Var f : TextRec) : Integer;
Begin
Nothing := 0;
End {Nothing} ;
Procedure Null(Ch : Char);
Begin
{}
End {Null} ;
Function DevOutput(Var f : TextRec) : Integer;
Var
i : Integer;
Begin
With f Do
Begin
{ f.BufPos contains the number of chars in the buffer }
{ f.BufPtr^ is your buffer }
{ Any variable conversion done by writeln is already }
{ done by now. }
i := 0;
While i < BufPos Do
Begin
AnsiWrite(BufPtr^[i]);
{$IFDEF BBS}
BBSHook(BufPtr^[i]);
{$ENDIF}
Inc(i);
End;
BufPos := 0;
End;
DevOutput := 0; { return IOResult Error codes here }
End {DevOutput} ;
Function DevOpen(Var f : TextRec) : Integer;
Begin
With f Do
Begin
If Mode = FmInput Then
Begin
InOutFunc := @Nothing;
FlushFunc := @Nothing;
End
Else
Begin
Mode := FmOutput; { in case it was FmInOut }
InOutFunc := @DevOutput;
FlushFunc := @DevOutput;
End;
CloseFunc := @Nothing;
End;
DevOpen := 0; { return IOResult error codes here }
End {DevOpen} ;
Procedure AssignAnsi(Var f : Text);
Begin
FillChar(f, SizeOf(f), #0); { init file var }
With TextRec(f) Do
Begin
Handle := $ffff;
Mode := FmClosed;
BufSize := SizeOf(Buffer);
BufPtr := @Buffer;
OpenFunc := @DevOpen;
Name[0] := #0;
End;
End {AssignAnsi} ;
{$ENDIF}
Begin
{$IFNDEF Small}
AssignAnsi(Ansi); { set up the variable }
Rewrite(Ansi); { open it for output }
{$IFDEF BBS}
BBsHook := Null;
{$ENDIF}
{$ENDIF}
Wrap := True;
ReplyHook := Report;
KeyHook := Dummy;
WriteHook := WriteChar;
{$IFDEF Music}
PlayHook := Dummy; { point play into the great music heaven }
{$ENDIF}
End.